{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
--
-- Module      :  LLVM.Code.Instructions.Branch
-- Copyright   :  Mikhail Belyaev
-- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module LLVM.Code.Instructions.Branch where

-- invoke may be considered a branching instruction too
import LLVM.Code.Shared (BBIndex(..), ValIndex(..), TypeIndex(..))
import LLVM.Parser.Record.Record
       (recordAsHeadlessList, recordAsList, RecordType(..))

import LLVM.Util
import LLVM.Code.Instructions.Class (BuildableInstruction(..))
import LLVM.Code.Instructions.Util
       (Unwrappable(..), Matched(..), Matcher(..), matchRRwithCode)
import LLVM.Code.Types (getTypeByIndex, Type)
import LLVM.Code.Instructions.Values
       (SwitchInstruction(..), IndirBranchInstruction(..),
        BranchInstruction(..), BranchInstruction)


instance BuildableInstruction BranchInstruction where
    buildInstruction rr tt vt =
        case (matchRRwithCode tt vt [MInteger, MInteger, MValue] 11 rr) of
             [MdInteger (BBIndex -> bb0), MdInteger (BBIndex -> bb1), MdValue v] ->
                    Just $ CondBranch bb0 bb1 v
             _ -> case (matchRRwithCode tt vt [MInteger] 11 rr) of
                       [MdInteger (BBIndex -> bb)] -> Just $ StraightBranch bb
                       _ -> Nothing



instance BuildableInstruction IndirBranchInstruction where
    buildInstruction rr tt vt =
        case (matchRRwithCode tt vt [MType, MValue, MMany MInteger] 31 rr) of
             [MdType ty, MdValue v, (unwrap -> Just (map BBIndex -> bbs))] ->
                Just IndirBranchInstruction {
                       ibrType           = ty,
                       ibrVal            = v,
                       ibrPossibleValues = bbs
                }
             _ -> Nothing



-- would take pain to match it with Matcher, but easy using old-style
instance BuildableInstruction SwitchInstruction where
    buildInstruction rr tt _
                     = case (recordAsHeadlessList rr) of
                            (12:((getTypeByIndex tt).TypeIndex -> Just ty):v:def:pvs) ->
                                              Just SwitchInstruction {
                                                   seOptype           = ty,
                                                   swOpval            = ValIndex v,
                                                   swDefault          = BBIndex def,
                                                   swCases            =
                                                        map(\(x,y) -> (ValIndex x, BBIndex y)) $
                                                           pairs pvs
                                              }
                            _ -> Nothing


